unit io;

interface

uses classes,sysutils,vm,compiler,unicode;

procedure forth_type(vm:TKsanaForthVM);
procedure forth_ztype(vm:TKsanaForthVM);
procedure forth_wztype(vm:TKsanaForthVM);
procedure forth_wtype(vm:TKsanaForthVM);
procedure iowords(vm:TKsanaForthVM);
procedure forth_dot(vm:TKsanaForthVM);

implementation

procedure forth_cr(vm:TKsanaForthVM);
 begin vm.cr;
end;

procedure forth_hdot(vm:TKsanaForthVM);
begin vm.appendoutput(format('%x ',[vm.pop]));
end;

procedure forth_hddot(vm:TKsanaForthVM);
begin vm.appendoutput(format('%x ',[vm.dpop]));
end;

procedure forth_hdotr(vm:TKsanaForthVM);
var f:string;
begin f:='%'+format('%dx',[vm.pop]);
      vm.appendoutput(format(f,[integer(vm.pop)]));
end;

procedure forth_zhdotr(vm:TKsanaForthVM);
var f:string; n:integer;
begin n:=vm.pop; f:='%0'+format('%d.%dx',[n,n]);
      vm.appendoutput(format(f,[integer(vm.pop)]));
end;

procedure forth_hddotr(vm:TKsanaForthVM);
var f:string;
begin f:='%'+format('%dx',[vm.pop]);
      vm.appendoutput(format(f,[vm.dpop]));
end;

procedure forth_zhddotr(vm:TKsanaForthVM);
var f:string;
begin f:='%0'+format('%dx',[vm.pop]);
      vm.appendoutput(format(f,[vm.dpop]));
end;

{procedure forth_zhdotr(vm:TKsanaForthVM);
var f:string; n:integer;
begin n:=vm.pop;
  f:='%0'+format('%d.%dx',[n,n]);
  vm.appendoutput(format(f,[integer(vm.pop)]));
end;}

procedure forth_dot(vm:TKsanaForthVM);
begin if vm.base=16 then
           forth_hdot(vm)
      else vm.appendoutput(inttostr(vm.pop)+' ');
end;

procedure forth_ddot(vm:TKsanaForthVM);
var
  d:int64;
begin
  if vm.base=16 then begin
    forth_hddot(vm); exit;
  end;
  d:=pint64(@vm.dstack[vm.sp-1])^; dec(vm.sp,2);
  vm.appendoutput(inttostr(d)+' ');
end;

procedure forth_dotr(vm:TKsanaForthVM);
var f:string;
begin
  if vm.base=16 then begin
    forth_hdotr(vm); exit;
  end;
  f:='%'+format('%dd',[vm.pop]);
  vm.appendoutput(format(f,[integer(vm.pop)]));
end;

procedure forth_zdotr(vm:TKsanaForthVM);
var f:string;
begin
  if vm.base=16 then begin
    forth_hdotr(vm); exit;
  end;
  f:='%0'+format('%dd',[vm.pop]);
  vm.appendoutput(format(f,[integer(vm.pop)]));
end;

procedure forth_ddotr(vm:TKsanaForthVM);
var f:string;
begin
  if vm.base=16 then begin
     forth_hddotr(vm); exit;
  end;
  f:='%'+format('%dd',[vm.pop]);
  vm.appendoutput(format(f,[integer(vm.dpop)]));
end;

procedure forth_zddotr(vm:TKsanaForthVM);
var f:string;
begin
  if vm.base=16 then begin
     forth_hddotr(vm); exit;
  end;
  f:='%0'+format('%dd',[vm.pop]);
  vm.appendoutput(format(f,[integer(vm.dpop)]));
end;

procedure forth_inputcheck(vm:TKsanaForthVM);
begin vm.tickinputcheck(vm);
end;

procedure forth_ztype(vm:TKsanaForthVM);
var s:string;
begin if not assigned(vm.tickztype) then exit;
  vm.consoleflush;
  s:=pchar(vm.pop);
  vm.tickztype(vm,pchar(s));
end;

procedure forth_wztype(vm:TKsanaForthVM);
var
  ws:pwidechar;
  s:string;
begin
  if not assigned(vm.tickztype) then exit;
  vm.consoleflush;

  ws:=pwidechar(vm.pop);

  s:=widestringtoutf8(ws);
  vm.tickztype(vm,pchar(s));
end;


procedure forth_wtype(vm:TKsanaForthVM);
var
  ws:widestring;
  s:string;
  c:integer;
begin
  if not assigned(vm.tickztype) then exit;
  vm.consoleflush;

  c:=vm.pop;
  ws:=pwidechar(vm.pop);
  ws:=copy(ws,1,c);

  s:=widestringtoutf8(ws);
  vm.tickztype(vm,pchar(s));
end;

procedure forth_type(vm:TKsanaForthVM);
var
  n:integer;
  s:string;
  p:pchar;
begin
  n:=vm.pop;
  s:=pchar(vm.tos);
  s:=copy(s,1,n);
  p:=pchar(s);
  vm.tos:=integer(p);
  forth_ztype(vm);
end;



procedure forth_emit(vm:TKsanaForthVM);
begin if not assigned(vm.tickemit) then exit;
      vm.consoleflush;
      vm.tickemit(vm,char(vm.pop));
end;

procedure forth_space(vm:TKsanaForthVM);
begin if not assigned(vm.tickemit) then exit;
      vm.consoleflush;
      vm.tickemit(vm,' ');
end;

procedure forth_spaces(vm:TKsanaForthVM);
var i:integer; s:string;
begin if not assigned(vm.tickztype) then exit;
      vm.consoleflush; s:='';
      for i:=1 to vm.pop do s:=s+' ';
      vm.tickztype(vm,pchar(s));
end;

procedure forth_fload(vm:TKsanaForthVM);
var s:string;
begin s:=vm.zword;
  vm.fload(pchar(s));
end;

procedure forth_preload(vm:TKsanaForthVM);
begin vm.preload;
end;

procedure forth_dotp(vm:TKsanaForthVM);
begin
  vm.push(integer(pchar(vm.zword(')'))));
  forth_ztype(vm);
end;

procedure forth_parent(vm:TKsanaForthVM);
begin vm.zword(')');
end;

procedure forth_bslash(vm:TKsanaForthVM);
begin vm.zword(#0); 
end;

procedure forth_base(vm:TKsanaForthVM);
begin vm.push(integer(@vm.base));
end;

procedure forth_hex(vm:TKsanaForthVM);
begin vm.base:=16;
end;

procedure forth_decimal(vm:TKsanaForthVM);
begin vm.base:=10;
end;

procedure forth_words(vm:TKsanaForthVM);
var
  i,n:integer; t:string;
  words:tstringlist;
begin
  words:=vm.createwords;
  n:=0;
  for i:=words.count-1 downto 0 do begin
    t:=' '+words[i]; inc(n,length(t));
    vm.appendoutput(t);
    if n>=60 then begin
      vm.cr;
      n:=0;
    end;
  end; vm.cr;
  words.free;
end;
{
procedure forth_fence(vm:TKsanaForthVM);
begin
 vm.push(integer(@vm.fence));
end;

procedure forth_pforget(vm:TKsanaForthVM);
begin
vm.forget(vm.pop);
end;
}
procedure iowords(vm:TKsanaForthVM);
begin
//  vm.addword('(forget)',integer(@forth_pforget));
//  vm.addword('fence',integer(@forth_fence));
  vm.addcodeword('base',integer(@forth_base)); //// ( a -- )
  vm.addcodeword('hex',integer(@forth_hex)); //// ( -- )
  vm.addcodeword('decimal',integer(@forth_decimal)); //// ( -- )
  vm.addcodeword('\',integer(@forth_bslash),true); //// ( <line> -- ) up to end of line
  vm.addcodeword('(',integer(@forth_parent),true,true); //// ( <comment> -- ) up to right parenthese
  vm.addcodeword('.(',integer(@forth_dotp)); //// ( <string> -- ) up to right parenthese
  vm.addcodeword('h.',integer(@forth_hdot)); //// ( i -- )
  vm.addcodeword('hd.',integer(@forth_hddot)); //// ( ilow ihigh -- )
  vm.addcodeword('h.r',integer(@forth_hdotr)); //// ( i n -- ) with leading spaces
  vm.addcodeword('hd.r',integer(@forth_hddotr)); //// ( i n -- ) with leading spaces
  vm.addcodeword('0h.r',integer(@forth_zhdotr)); //// ( i n -- ) with leading zeros
  vm.addcodeword('0hd.r',integer(@forth_zhddotr)); //// ( i n -- ) with leading spaces
  vm.addcodeword('.',integer(@forth_dot)); //// ( i -- )
  vm.addcodeword('d.',integer(@forth_ddot)); //// ( ilow ihigh -- )
  vm.addcodeword('.r',integer(@forth_dotr)); //// ( i n -- )
  vm.addcodeword('d.r',integer(@forth_ddotr)); //// ( ilow ihigh n -- )
  vm.addcodeword('0.r',integer(@forth_zdotr)); //// ( i n -- )
  vm.addcodeword('0d.r',integer(@forth_zddotr)); //// ( ilow ihigh n -- )
  vm.addcodeword('cr',integer(@forth_cr)); //// ( -- )
  vm.addcodeword('type',integer(@forth_type)); //// ( a n -- )
  vm.addcodeword('wztype',integer(@forth_wztype)); //// ( a -- )
  vm.addcodeword('wtype',integer(@forth_wtype)); //// ( a n -- )
  vm.addcodeword('ztype',integer(@forth_ztype)); //// ( a -- )
  vm.addcodeword('emit',integer(@forth_emit)); //// ( c -- )
  vm.addcodeword('space',integer(@forth_space)); //// ( -- )
  vm.addcodeword('spaces',integer(@forth_spaces)); //// ( n -- )
  vm.addcodeword('fload',integer(@forth_fload)); //// ( <file> -- )
  vm.addcodeword('preload',integer(@forth_preload)); //// ( -- )
end;

end.
